home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / tdecl / runtime-types.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  7.3 KB  |  229 lines  |  [TEXT/CCL2]
  1.  
  2. ;;; This creates runtime definitions for the datatypes
  3.  
  4. (define (add-runtime-type-definitions)
  5.   (dolist (alg (module-alg-defs *module*))
  6.     (add-new-module-def
  7.      (algdata-runtime-var alg)
  8.      (**app (**con/def (core-symbol "MkDataType"))
  9.         (**string (symbol->string (def-name alg)))  ; Name
  10.         (**string-to-symbol                         ; FullName
  11.             (**string (string-append
  12.              (symbol->string (def-module alg))
  13.              ":"
  14.              (symbol->string (def-name alg)))))
  15.         (**int (length (algdata-tyvars alg)))       ; Arity
  16.         (generate-con-list alg)
  17.         (**bool (algdata-tuple? alg))               ; Tuple
  18.         (**bool (algdata-enum? alg))                ; Enum
  19.         (**bool (algdata-real-tuple? alg))          ; RealTuple
  20.         (**app (**var/def (core-symbol "fetchInstances"))
  21.            (**var/def (algdata-runtime-var alg))
  22.            (**var/def (core-symbol "allInstances")))
  23.         (generate-con-test alg))))
  24.  
  25.     ;; Note: major magic is used to plug the instances into the data types
  26.     ;; at runtime.  See runtime-utils.scm.
  27.  
  28.   (dolist (class (module-class-defs *module*))
  29.     (add-new-module-def
  30.      (class-runtime-var class)
  31.      (**app (**con/def (core-symbol "MkClass"))
  32.         (**string (symbol->string (def-name class)))  ; Name
  33.         (**string-to-symbol                         ; FullName
  34.           (**string (string-append
  35.              (symbol->string (def-module class))
  36.              ":"
  37.              (symbol->string (def-name class)))))
  38.         (**list/l
  39.          (map (lambda (x) (**var/def (class-runtime-var x)))
  40.           (class-super* class)))
  41.         (**list/l
  42.          (map (lambda (c) (**cast
  43.                                (**lambda '(x)
  44.                 (**cast
  45.                  (**dsel/dict class c (**cast (**var 'x)))))))
  46.           (class-super* class))))))
  47.   (dolist (inst (module-instance-defs *module*))
  48.     (add-new-module-def
  49.      (instance-runtime-var inst)
  50.      (**app (**con/def (core-symbol "MkInstance"))
  51.         (rconvert-tycon (instance-algdata inst))
  52.         (**var/def (class-runtime-var (forward-def (instance-class inst))))
  53.         (make overloaded-var-ref
  54.           (var (instance-dictionary inst))
  55.           (sig (**gtype '() (**ntycon (core-symbol "Magic") '()))))
  56.         (rconvert-context (instance-gcontext inst)))))
  57.   (add-new-module-def
  58.     (make-new-var (symbol->string (module-instance-var-name *module*)))
  59.     (**list/l (map (lambda (i) (**var/def (instance-runtime-var i)))
  60.            (module-instance-defs *module*)))))
  61.  
  62. (define (con->pat c)
  63.   (let ((l '()))
  64.     (dotimes (i (con-arity c))
  65.       (push '_ l))
  66.     (cons c l)))
  67.  
  68. (define (create-runtime-selector-fns con i n)
  69.   (if (>= i n)
  70.       '()
  71.       (cons (**cast (**lambda '(x)
  72.                   (**sel con (**var 'x) i)))
  73.         (create-runtime-selector-fns con (1+ i) n))))
  74.  
  75. (define (rconvert-fixity f)
  76.   (if (eq? f '#f)
  77.       (**con/def (core-symbol "NoFixity"))
  78.       (let ((a (fixity-associativity f)))
  79.        (**app (**con/def (cond ((eq? a 'l) (core-symbol "InfixL"))
  80.                    ((eq? a 'r) (core-symbol "InfixR"))
  81.                    ((eq? a 'n) (core-symbol "InfixN"))))
  82.           (**int (fixity-precedence f))))))
  83.  
  84. (define (**string-to-symbol x)
  85.   (**app (**var/def (core-symbol "stringToSymbol")) x))
  86.  
  87. ;;; Stuff for constructors
  88.  
  89. ;;; This function produces Haskell code that will create a list
  90. ;;; of Constructor objects for a data type
  91.  
  92. (define (generate-con-list alg)
  93.   (if (algdata-enum? alg)
  94.       (if (algdata-implemented-by-lisp? alg)
  95.       (**app
  96.           (**var/def (core-symbol "createLispEnumConstructors"))
  97.           (**var/def (algdata-runtime-var alg))
  98.           (**string (create-enum-constructor-name-string alg))
  99.           (**list/l
  100.            (map (lambda (con) (**cast (**con/def con)))
  101.             (algdata-constrs alg))))
  102.       (**app 
  103.               (**var/def (core-symbol "createEnumConstructors"))
  104.           (**var/def (algdata-runtime-var alg))
  105.           (**string (create-enum-constructor-name-string alg))))
  106.       (mlet (((s ac at) (create-constructor-name-string alg))
  107.          (class-list (**list/l (map (lambda (c)
  108.                       (**var/def (class-runtime-var c)))
  109.                     ac)))
  110.          (type-list (**list/l (map (function rconvert-tycon) at))))
  111.      (**app (**var/def (core-symbol "createConstructors"))
  112.         (**var/def (algdata-runtime-var alg))
  113.         (**string s)
  114.         class-list
  115.         type-list
  116.         (if (algdata-implemented-by-lisp? alg)
  117.             (**list/l (map
  118.                    (lambda (c)
  119.                      (let ((fns (create-runtime-selector-fns
  120.                          c 0 (con-arity c))))
  121.                    (**list/l 
  122.                     (cons (**cast (**con/def c)) fns))))
  123.                    (algdata-constrs alg)))
  124.             (**null))))))
  125.  
  126. (define (create-enum-constructor-name-string alg)
  127.   (call-with-output-string
  128.    (lambda (p)
  129.      (dolist (c (algdata-constrs alg))
  130.        (format p "~A~%" (remove-con-prefix (symbol->string (def-name c))))))))
  131.  
  132. (define (create-constructor-name-string alg)
  133.  (let* ((all-types '())
  134.     (all-classes '())
  135.     (str
  136.      (call-with-output-string
  137.       (lambda (p)
  138.         (dolist (c (algdata-constrs alg))
  139.          (format p "~A;" (remove-con-prefix (symbol->string (def-name c))))
  140.          (when (con-fixity c)
  141.            (format p "~A~A" (fixity-associativity (con-fixity c))
  142.                         (fixity-precedence (con-fixity c))))
  143.          (format p ";")
  144.          (mlet (((ac at)
  145.          (encode-signature (con-signature c) p all-classes all-types)))
  146.           (setf all-classes ac)
  147.           (setf all-types at)
  148.           (format p ";")
  149.           (dolist (s (con-slot-strict? c))
  150.          (format p "~A" (if s "S" "N")))
  151.           (format p ";~A;~%" (if (con-infix? c) "I" ""))))))))
  152.     (values str all-classes all-types)))
  153.  
  154. (define (encode-signature s p ac at)
  155.   (let ((ac1 (encode-context (gtype-context s) ac p)))
  156.     (values ac1 (encode-type (gtype-type s) at p))))
  157.  
  158. (define (encode-context cs ac p)
  159.   (write-char '#\[ p)
  160.   (let ((s '#t))
  161.     (dolist (c cs)
  162.        (if s
  163.           (setf s '#f)
  164.       (write-char '#\, p))
  165.        (write-char #\[ p)
  166.        (let ((s1 '#t))
  167.      (dolist (ctxt c)
  168.        (if s1
  169.              (setf s1 '#f)
  170.          (write-char '#\, p))
  171.            (mlet (((ac1 i) (encode-ct (forward-def ctxt) ac ac 0)))
  172.          (format p "~A" i)
  173.          (setf ac ac1)))
  174.      (write-char '#\] p)))
  175.     (write-char '#\] p))
  176.   ac)
  177.  
  178. (define (encode-ct ct cts all i)
  179.   (if (null? cts)
  180.       (values (append all (list ct)) i)
  181.       (if (eq? ct (car cts))
  182.       (values all i)
  183.       (encode-ct ct (cdr cts) all (1+ i)))))
  184.  
  185. (define (encode-type ty at p)
  186.   (setf ty (expand-ntype-synonym ty))
  187.   (if (gtyvar? ty)
  188.       (begin 
  189.     (format p "~A" (gtyvar-varnum ty))
  190.     at)
  191.       (mlet (((at1 i) (encode-ct (forward-def (ntycon-tycon ty)) at at 0)))
  192.     (format p "~A(" i)
  193.     (encode-type/l (ntycon-args ty) '#t at1 p))))
  194.  
  195. (define (encode-type/l tys s at p)
  196.   (cond ((null? tys)
  197.      (write-char #\) p)
  198.      at)
  199.     (else
  200.      (unless s (write-char #\, p))
  201.      (let ((at1 (encode-type (car tys) at p)))
  202.        (encode-type/l (cdr tys) '#f at1 p)))))
  203.  
  204. ;;; This returns a Haskell function which will return a constructor object
  205. ;;; at rutime.
  206.  
  207. (define (generate-con-test alg)
  208.   (cond ((algdata-implemented-by-lisp? alg)
  209.      (**app (**var/def (core-symbol "makeLispConstrFn"))
  210.         (**var/def (algdata-runtime-var alg))
  211.         (**list/l
  212.          (map (lambda (con)
  213.             (**cast
  214.              (**lambda '(x) (**is-constructor (**var 'x) con))))
  215.               (algdata-constrs alg)))))
  216.     ((algdata-tuple? alg)
  217.      (**app (**var/def (core-symbol "makeGTupleConstrFn"))
  218.         (**var/def (algdata-runtime-var alg))))
  219.     ((algdata-enum? alg)
  220.      (**app (**var/def (core-symbol "makeEnumConstrFn"))
  221.         (**var/def (algdata-runtime-var alg))))
  222.     (else
  223.      (**app (**var/def (core-symbol "makeConstrFn"))
  224.         (**var/def (algdata-runtime-var alg))))))
  225.  
  226.  
  227.              
  228.  
  229.